home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_200 / 231_01 / primitiv.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-15  |  35.0 KB  |  1,392 lines
  1. /*
  2.     Little Smalltalk
  3.  
  4.     Primitive manager
  5.     timothy a. budd
  6.     10/84
  7.  
  8.         hashcode code written by Robert McConeghy
  9.             (who also wrote classes Dictionary, et al).
  10. */
  11. /*
  12.     The source code for the Little Smalltalk System may be freely
  13.     copied provided that the source of all files is acknowledged
  14.     and that this condition is copied with each file.
  15.  
  16.     The Little Smalltalk System is distributed without responsibility
  17.     for the performance of the program and without any guarantee of
  18.     maintenance.
  19.  
  20.     All questions concerning Little Smalltalk should be addressed to:
  21.  
  22.         Professor Tim Budd
  23.         Department of Computer Science
  24.         Oregon State University
  25.         Corvallis, Oregon
  26.         97331
  27.         USA
  28. */
  29.  
  30. # include "object.h"
  31.  
  32. # ifdef CURSES
  33. # include <curses.h>
  34. # endif
  35.  
  36. # include <stdio.h>
  37. # include <ctype.h>
  38. # include <math.h>
  39. # include <errno.h>
  40. # include "drive.h"
  41. # include "interp.h"
  42. # include "process.h"
  43. # include "block.h"
  44. # include "string.h"
  45. # include "symbol.h"
  46. # include "number.h"
  47. # include "file.h"
  48. # include "byte.h"
  49. # include "primitive.h"
  50.  
  51. extern int errno;
  52. extern int prntcmd;
  53. extern double modf();
  54. extern long time();
  55. extern object *lookup_class();
  56. extern process *runningProcess;
  57. extern int responds_to(), generality();
  58. extern class  *mk_class();
  59. extern object *o_object, *o_true, *o_false, *o_nil, *o_number, *o_magnitude;
  60.  
  61. object *primitive(primnumber, numargs, args)
  62. int primnumber, numargs;
  63. object **args;
  64. {    object *resultobj;
  65.     object *leftarg, *rightarg, *fnd_class(), *fnd_super();
  66.     int    leftint, rightint, i, j;
  67.     double leftfloat, rightfloat;
  68.     long   clock;
  69.     char   *leftp, *rightp, *errp;
  70.     class  *aClass;
  71.     bytearray *byarray;
  72.     struct file_struct *phil;
  73.     int    opnumber = primnumber % 10;
  74.     char   strbuffer[300], tempname[100];
  75.  
  76.     errno = 0;
  77.     /* first do argument type checking */
  78.     switch(i = (primnumber / 10)) {
  79.         case 0: /* misc operations */
  80.             if (opnumber <= 5 && numargs != 1) goto argcerror;
  81.             leftarg = args[0];
  82.             break;
  83.  
  84.         case 1: /* integer operations */
  85.         case 2:
  86.             if (numargs != 2) goto argcerror;
  87.             rightarg = args[1];
  88.             if (! is_integer(rightarg)) goto argterror;
  89.             rightint = int_value(rightarg);
  90.         case 3:
  91.             if (i == 3 && opnumber && numargs != 1)
  92.                 goto argcerror;
  93.             leftarg = args[0];
  94.             if (! is_integer(leftarg)) goto argterror;
  95.             leftint = int_value(leftarg);
  96.             break;
  97.  
  98.         case 4: /* character operations */
  99.             if (numargs != 2) goto argcerror;
  100.             rightarg = args[1];
  101.             if (! is_character(rightarg)) goto argterror;
  102.             rightint = int_value(rightarg);
  103.         case 5:
  104.             if (i == 5 && numargs != 1) goto argcerror;
  105.             leftarg = args[0];
  106.             if (! is_character(leftarg)) goto argterror;
  107.             leftint = int_value(leftarg);
  108.             break;
  109.  
  110.         case 6: /* floating point operations */
  111.             if (numargs != 2) goto argcerror;
  112.             rightarg = args[1];
  113.             if (! is_float(rightarg)) goto argterror;
  114.             rightfloat = float_value(rightarg);
  115.         case 7:
  116.             if (i == 7 && numargs != 1) goto argcerror;
  117.         case 8:
  118.             if (i == 8 && opnumber < 8 && numargs != 1)
  119.                 goto argcerror;
  120.             leftarg = args[0];
  121.             if (! is_float(leftarg)) goto argterror;
  122.             leftfloat = float_value(leftarg);
  123.             break;
  124.  
  125.         case 9: /* symbol operations */
  126.             leftarg = args[0];
  127.             if (! is_symbol(leftarg)) goto argterror;
  128.             leftp = symbol_value(leftarg);
  129.             break;
  130.  
  131.         case 10: /* string operations */
  132.             if (numargs < 1) goto argcerror;
  133.             leftarg = args[0];
  134.             if (! is_string(leftarg)) goto argterror;
  135.             leftp = string_value(leftarg);
  136.             if (opnumber && opnumber <= 3) {
  137.                 if (numargs != 2) goto argcerror;
  138.                 rightarg = args[1];
  139.                 if (! is_string(rightarg)) goto argterror;
  140.                 rightp = string_value(rightarg);
  141.                 }
  142.             else if ((opnumber >= 4) && (opnumber <= 6)) {
  143.                 if (numargs < 2) goto argcerror;
  144.                 if (! is_integer(args[1])) goto argterror;
  145.                 i = int_value(args[1])-1;
  146.                 if ((i < 0) || (i >= strlen(leftp)))
  147.                     goto indexerror;
  148.                 }
  149.             else if ((opnumber >= 7) && (numargs != 1))
  150.                 goto argcerror;
  151.             break;
  152.  
  153.         case 11: /* misc operations */
  154.             if ((opnumber == 1) || (opnumber == 2)) {
  155.                 if (is_bltin(args[0])) goto argterror;
  156.                 if (numargs < 2) goto argcerror;
  157.                 if (! is_integer(args[1])) goto argterror;
  158.                 i = int_value(args[1]);
  159.                 if (i < 1 || i > args[0]->size)
  160.                     goto indexerror;
  161.                 }
  162.             else if ((opnumber >= 4) && (opnumber <= 6)) {
  163.                 if (numargs != 1) goto argcerror;
  164.                 if (! is_integer(args[0])) goto argterror;
  165.                 i = int_value(args[0]);
  166.                 if (i < 0) goto indexerror;
  167.                 }
  168.             else if (opnumber >= 7) {
  169.                 if (numargs < 1) goto argcerror;
  170.                 if (! is_bytearray(args[0])) goto argterror;
  171.                 byarray = (bytearray *) args[0];
  172.                 if (opnumber >= 8) {
  173.                     if (numargs < 2) goto argcerror;
  174.                     if (! is_integer(args[1]))
  175.                         goto argterror;
  176.                     i = int_value(args[1]) - 1;
  177.                     if (i < 0 || i >= byarray->a_bsize)
  178.                         goto indexerror;
  179.                     }
  180.                 }
  181.             break;
  182.  
  183.         case 12: /* string i/o operations */
  184.             if (opnumber < 6) {
  185.                 if (numargs < 1) goto argcerror;
  186.                 leftarg = args[0];
  187.                 if (! is_string(leftarg)) goto argterror;
  188.                 leftp = string_value(leftarg);
  189.                 }
  190.             break;
  191.  
  192.         case 13: /* operations on file */
  193.             if (numargs < 1) goto argcerror;
  194.             if (! is_file(args[0])) goto argterror;
  195.             phil = (struct file_struct *) args[0];
  196.             if (opnumber && (phil->fp == (FILE *) NULL)) {
  197.                 errp = "file must be open for operation";
  198.                 goto return_error;
  199.                 }
  200.             break;
  201.  
  202.         case 15: /* operations on classes */
  203.             if (opnumber < 3 && numargs != 1) goto argcerror;
  204.             if (! is_class(args[0])) goto argterror;
  205.             aClass = (class *) args[0];
  206.             break;
  207.  
  208. # ifdef PLOT3
  209.         case 17: /* plot(3) interface */
  210.             if (opnumber && opnumber <= 3) {
  211.                 if (numargs != 2) goto argcerror;
  212.                 if ((! is_integer(args[0])) ||
  213.                     (! is_integer(args[1])))
  214.                     goto argterror;
  215.                 leftint = int_value(args[0]);
  216.                 rightint = int_value(args[1]);
  217.                 }
  218.             else if ((opnumber == 6) || (opnumber == 7)) {
  219.                 if (numargs != 4) goto argcerror;
  220.                 for (i = 0; i < 4; i++)
  221.                     if (! is_integer(args[i]))
  222.                         goto argterror;
  223.                 leftint = int_value(args[0]);
  224.                 rightint = int_value(args[1]);
  225.                 i = int_value(args[2]);
  226.                 j = int_value(args[3]);
  227.                 }
  228.             else if (opnumber >= 8) {
  229.                 if (numargs != 1) goto argcerror;
  230.                 if (! is_string(args[0])) goto argterror;
  231.                 leftp = string_value(args[0]);
  232.                 }
  233.             break;
  234. # endif
  235.         }
  236.  
  237.  
  238.     /* now do operation */
  239.     switch(primnumber) {
  240.  
  241.         case 1:        /* class of object */
  242.             resultobj = fnd_class(args[0]);
  243.             if (resultobj) goto return_obj;
  244.             else goto return_nil;
  245.  
  246.         case 2:        /* get super_object */
  247.             resultobj = fnd_super(args[0]);
  248.             if (resultobj) goto return_obj;
  249.             else goto return_nil;
  250.  
  251.         case 3:        /* see if class responds to new */
  252.             leftint = 0;
  253.             if (! is_class(args[0])) goto return_boolean;
  254.             leftint = responds_to("new", (class *) args[0]);
  255.             goto return_boolean;
  256.  
  257.         case 4:        /* compute size of object */
  258.             leftint = args[0]->size;
  259.             goto return_integer;
  260.  
  261.         case 5:        /* return hashnum of object */
  262.             if (is_integer(leftarg))
  263.                 leftint = int_value(leftarg);
  264.             else if (is_character(leftarg))
  265.                 leftint = int_value(leftarg);
  266.             else if (is_symbol(leftarg))
  267.                 leftint = (int) symbol_value(leftarg);
  268.             else if (is_string(leftarg)) {
  269.                 leftp = string_value(leftarg);
  270.                 leftint = 0;
  271.                 for(i = 0; *leftp != 0; leftp++){
  272.                     leftint += *leftp;
  273.                     i++;
  274.                     if(i > 5)
  275.                        break;
  276.                     }
  277.                 }
  278.             else /* for all other objects return address */
  279.                 leftint = (int) &leftarg;
  280.             if (leftint < 0)
  281.                 leftint = -leftint;
  282.             goto return_integer;
  283.  
  284.         case 6:        /* built in object type testing */
  285.             if (numargs != 2) goto argcerror;
  286.             leftint = 0;
  287.             if (is_bltin(args[0]) == is_bltin(args[1]))
  288.                 if (is_bltin(args[0]))
  289.                     leftint = (args[0]->size == args[1]->size);
  290.                 else leftint = (args[0]->class == args[1]->class);
  291.             goto return_boolean;
  292.  
  293.         case 7:        /* object equality testing */
  294.             if (numargs != 2) goto argcerror;
  295.             leftint = (args[0] == args[1]);
  296.             goto return_boolean;
  297.  
  298.         case 8:        /* toggle debugging flag */
  299.             if (numargs == 0) {
  300.                 debug = 1 - debug;
  301.                 goto return_nil;
  302.                 }
  303.             if (numargs != 2) goto argcerror;
  304.             if (! is_integer(args[0])) goto argterror;
  305.             if (! is_integer(args[1])) goto argterror;
  306.             leftint = int_value(args[0]);
  307.             rightint = int_value(args[1]);
  308.             switch(leftint) {
  309.                 case 1: prntcmd = rightint; break;
  310.                 case 2: debug = rightint; break;
  311.                 }
  312.             goto return_nil;
  313.  
  314.         case 9:        /* numerical generality comparison */
  315.             if (numargs != 2) goto argcerror;
  316.             leftint =
  317.                 (generality(args[0]) > generality(args[1]));
  318.             goto return_boolean;
  319.  
  320.         case 10:    /* integer addition */
  321.             leftint += rightint;
  322.             goto return_integer;
  323.  
  324.         case 11:    /* integer subtraction */
  325.             leftint -= rightint;
  326.             goto return_integer;
  327.  
  328.         case 12: case 42:
  329.             leftint = (leftint < rightint);
  330.             goto return_boolean;
  331.  
  332.         case 13: case 43:
  333.             leftint = (leftint > rightint);
  334.             goto return_boolean;
  335.  
  336.         case 14: case 44:
  337.             leftint = (leftint <= rightint);
  338.             goto return_boolean;
  339.  
  340.         case 15: case 45:
  341.             leftint = (leftint >= rightint);
  342.             goto return_boolean;
  343.  
  344.         case 16: case 46:
  345.             leftint = (leftint == rightint);
  346.             goto return_boolean;
  347.  
  348.         case 17: case 47:
  349.             leftint = (leftint != rightint);
  350.             goto return_boolean;
  351.  
  352.         case 18:
  353.             leftint *= rightint;
  354.             goto return_integer;
  355.  
  356.         case 19:    /* // integer */
  357.             if (rightint == 0) goto numerror;
  358.             i  = leftint / rightint;
  359.             if ((leftint < 0) && (leftint % rightint))
  360.                 i -= 1;
  361.             leftint = i;
  362.             goto return_integer;
  363.  
  364.         case 20:    /* gcd of two integers */
  365.             if (leftint == 0 || rightint == 0) goto numerror;
  366.             if (leftint < 0) leftint = -leftint;
  367.             if (rightint < 0) rightint = -rightint;
  368.             if (leftint > rightint)
  369.                 {i = leftint; leftint = rightint; rightint = i;}
  370.             while (i = rightint % leftint)
  371.                 {rightint = leftint; leftint = i;}
  372.             goto return_integer;
  373.             
  374.         case 21:    /* bitAt: */
  375.             leftint = (leftint & (1 << rightint)) ? 1 : 0;
  376.             goto return_integer;
  377.  
  378.         case 22:    /* logical bit-or */
  379.             leftint |= rightint;
  380.             goto return_integer;
  381.  
  382.         case 23:    /* logical bit-and */
  383.             leftint &= rightint;
  384.             goto return_integer;
  385.  
  386.         case 24:    /* logical bit-exclusive or */
  387.             leftint ^= rightint;
  388.             goto return_integer;
  389.  
  390.         case 25:    /* bit shift */
  391.             if (rightint < 0)
  392.                 leftint >>= - rightint;
  393.             else
  394.                 leftint <<= rightint;
  395.             goto return_integer;
  396.  
  397.         case 26:    /* integer radix */
  398.             if (rightint < 2 || rightint > 36) goto numerror;
  399.             prnt_radix(leftint, rightint, strbuffer);
  400.             goto return_string;
  401.  
  402.         case 28:
  403.             if (rightint == 0) goto numerror;
  404.             leftint /= rightint;
  405.             goto return_integer;
  406.  
  407.         case 29:
  408.             if (rightint == 0) goto numerror;
  409.             leftint %= rightint;
  410.             goto return_integer;
  411.  
  412.         case 30:    /* doPrimitive:withArguments: */
  413.             if (numargs != 2) goto argcerror;
  414.             resultobj = primitive(leftint, args[1]->size,
  415.                 &args[1]->inst_var[0]);
  416.             goto return_obj;
  417.  
  418.         case 32:    /* convert random int into random float */
  419.             leftfloat = ((double) ((leftint/10) % 1000)) / 1000.0;
  420.             goto return_float;
  421.  
  422.         case 33:    /* bit inverse */
  423.             leftint ^= -1;
  424.             goto return_integer;
  425.  
  426.         case 34:    /* highBit */
  427.             rightint = leftint;
  428.             for (leftint = 32; leftint >= 0; leftint--)
  429.                 if (rightint & (1 << leftint))
  430.                     goto return_integer;
  431.             goto return_nil;
  432.  
  433.         case 35:    /* random number */
  434.             srand(leftint);
  435.             leftint = rand();
  436.             goto return_integer;
  437.  
  438.         case 36:    /* convert integer to character */
  439.             goto return_character;
  440.  
  441.         case 37:    /* convert integer to string */
  442.             sprintf(strbuffer,"%d", leftint);
  443.             goto return_string;
  444.  
  445.         case 38:    /* factorial */
  446.             if (leftint < 0) goto numerror;
  447.             if (leftint < FACTMAX) {
  448.                 for (i = 1; leftint; leftint--)
  449.                     i *= leftint;
  450.                 leftint = i;
  451.                 goto return_integer;
  452.                 }
  453. # ifndef GAMMA
  454.             /* gamma not supported, use float multiply */
  455.             leftfloat = 1.0;
  456.             if (leftint < 30) {
  457.                 for (i = 1; leftint; leftint--)
  458.                     leftfloat *= leftint;
  459.                 }
  460.             goto return_float;
  461. # endif
  462. # ifdef GAMMA
  463.             /* compute gamma */
  464.             leftfloat = (double) (leftint + 1);
  465.             sassign(leftarg, new_float(leftfloat));
  466.             resultobj = primitive(GAMMAFUN, 1, &leftarg);
  467.             obj_dec(leftarg);
  468.             goto return_obj;
  469. # endif
  470.  
  471.         case 39:    /* convert integer to float */
  472.             leftfloat = (double) leftint;
  473.             goto return_float;
  474.  
  475.         case 50:    /* digitValue */
  476.             if (isdigit(leftint))
  477.                 leftint -= '0';
  478.             else if (isupper(leftint)) {
  479.                 leftint -= 'A';
  480.                 leftint += 10;
  481.                 }
  482.             else goto return_nil;
  483.             goto return_integer;
  484.  
  485.         case 51:
  486.             if (isupper(leftint)) leftint += 'a' - 'A';
  487.             leftint = (leftint == 'a') || (leftint == 'e') ||
  488.                   (leftint == 'i') || (leftint == 'o') ||
  489.                   (leftint == 'u');
  490.             goto return_boolean;
  491.  
  492.         case 52:
  493.             leftint = isalpha(leftint);
  494.             goto return_boolean;
  495.  
  496.         case 53:
  497.             leftint = islower(leftint);
  498.             goto return_boolean;
  499.  
  500.         case 54:
  501.             leftint = isupper(leftint);
  502.             goto return_boolean;
  503.  
  504.         case 55:
  505.             leftint = isspace(leftint);
  506.             goto return_boolean;
  507.  
  508.         case 56:
  509.             leftint = isalnum(leftint);
  510.             goto return_boolean;
  511.  
  512.         case 57:
  513.             if (isupper(leftint)) leftint += 'a' - 'A';
  514.             else if (islower(leftint)) leftint += 'A' - 'a';
  515.             goto return_character;
  516.  
  517.         case 58:    /* convert character to string */
  518.             sprintf(strbuffer,"%c", leftint);
  519.             goto return_string;
  520.  
  521.         case 59:    /* convert character to integer */
  522.             goto return_integer;
  523.  
  524.         case 60:    /* floating point addition */
  525.             leftfloat += rightfloat;
  526.             goto return_float;
  527.  
  528.         case 61:    /* floating point subtraction */
  529.             leftfloat -= rightfloat;
  530.             goto return_float;
  531.  
  532.         case 62:
  533.             leftint = (leftfloat < rightfloat);
  534.             goto return_boolean;
  535.  
  536.         case 63:
  537.             leftint = (leftfloat > rightfloat);
  538.             goto return_boolean;
  539.  
  540.         case 64:
  541.             leftint = (leftfloat <= rightfloat);
  542.             goto return_boolean;
  543.  
  544.         case 65:
  545.             leftint = (leftfloat >= rightfloat);
  546.             goto return_boolean;
  547.  
  548.         case 66:
  549.             leftint = (leftfloat == rightfloat);
  550.             goto return_boolean;
  551.  
  552.         case 67:
  553.             leftint = (leftfloat != rightfloat);
  554.             goto return_boolean;
  555.  
  556.         case 68:
  557.             leftfloat *= rightfloat;
  558.             goto return_float;
  559.  
  560.         case 69:
  561.             if (rightfloat == 0) goto numerror;
  562.             leftfloat /= rightfloat;
  563.             goto return_float;
  564.  
  565.         case 70:
  566.             leftfloat = log(leftfloat);
  567.             goto float_check;
  568.  
  569.         case 71:
  570.             if (leftfloat < 0) goto numerror;
  571.             leftfloat = sqrt(leftfloat);
  572.             goto float_check;
  573.  
  574.         case 72:
  575.             leftint = (int) floor(leftfloat);
  576.             goto return_integer;
  577.  
  578.         case 73:    /* ceiling */
  579.             leftint = (int) ceil(leftfloat);
  580.             goto return_integer;
  581.  
  582.         case 75:    /* integer part */
  583.             leftfloat = modf(leftfloat, &rightfloat);
  584.             leftint = (int) rightfloat;
  585.             goto return_integer;
  586.  
  587.         case 76:    /* fractional part */
  588.             leftfloat = modf(leftfloat, &rightfloat);
  589.             goto return_float;
  590.  
  591.         case 77:    /* gamma function */
  592. # ifdef GAMMA
  593.             leftfloat = gamma(leftfloat);
  594.             if (leftfloat > 88.0) goto numerror;
  595.             leftfloat = exp(leftfloat);
  596.             goto float_check;
  597. # endif
  598. # ifndef GAMMA
  599.             errp = "gamma function";
  600.             goto not_implemented;
  601. # endif
  602.  
  603.         case 78:
  604.             sprintf(strbuffer,"%g", leftfloat);
  605.             goto return_string;
  606.  
  607.         case 79:
  608.             leftfloat = exp(leftfloat);
  609.             goto return_float;
  610.  
  611.         case 80:    /* normalize radian value */
  612. # define TWOPI (double) 6.2831853072
  613.             rightfloat =
  614.             floor(((leftfloat < 0) ? -leftfloat:leftfloat) / TWOPI);
  615.             if (leftfloat < 0)
  616.                 leftfloat += (1 + rightfloat) * TWOPI;
  617.             else
  618.                 leftfloat -= rightfloat * TWOPI;
  619.             goto return_float;
  620.  
  621.         case 81:
  622.             leftfloat = sin(leftfloat);
  623.             goto float_check;
  624.  
  625.         case 82:
  626.             leftfloat = cos(leftfloat);
  627.             goto float_check;
  628.  
  629.         case 84:
  630.             leftfloat = asin(leftfloat);
  631.             goto float_check;
  632.  
  633.         case 85:
  634.             leftfloat = acos(leftfloat);
  635.             goto float_check;
  636.  
  637.         case 86:
  638.             leftfloat = atan(leftfloat);
  639.             goto float_check;
  640.  
  641.         case 88:
  642.             if (numargs != 2) goto argcerror;
  643.             if (! is_float(args[1])) goto argterror;
  644.             leftfloat = pow(leftfloat, float_value(args[1]));
  645.             goto float_check;
  646.  
  647.         case 89:    /* floating point radix */
  648.             if (numargs != 2) goto argcerror;
  649.             if (! is_integer(args[1])) goto argterror;
  650.             i = int_value(args[1]); /* base */
  651.             if (i < 2 || i > 36) goto numerror;
  652.             fprnt_radix(leftfloat, i, strbuffer);
  653.             goto return_string;
  654.  
  655.         case 91:    /* symbol comparison */
  656.             if (numargs != 2) goto argcerror;
  657.             if (! is_symbol(args[1])) goto argterror;
  658.             leftint = (leftp == symbol_value(args[1]));
  659.             goto return_boolean;
  660.  
  661.         case 92:    /* symbol printString */
  662.             sprintf(strbuffer, "#%s", leftp);
  663.             goto return_string;
  664.  
  665.         case 93:    /* symbol asString */
  666.             sprintf(strbuffer, "%s", leftp);
  667.             goto return_string;
  668.  
  669.         case 94:    /* symbol print ( with tabs) */
  670.             if (numargs == 2) {
  671.                 if (! is_integer(args[1])) goto argterror;
  672.                 for (i = int_value(args[1]); i >= 0; i--)
  673.                     putchar('\t');
  674.             }
  675.             printf("%s\n", leftp);
  676. # ifdef FLUSHREQ
  677.             fflush(stdout);
  678. # endif
  679.             goto return_nil;
  680.  
  681.         case 96:
  682.             goto return_nil;
  683.  
  684.         case 97:    /* make a new class (generated by parser)*/
  685.             if (numargs != 8) goto argcerror;
  686.             if (! is_symbol(args[1])) goto argterror;
  687.             if (! is_symbol(args[2])) goto argterror;
  688.             if (! is_integer(args[6])) goto argterror;
  689.             if (! is_integer(args[7])) goto argterror;
  690.             resultobj = (object *) mk_class(leftp, args);
  691.             goto return_obj;
  692.  
  693.         case 98:    /* install class in dictionary */
  694.             if (numargs != 2) goto argcerror;
  695.             if (! is_class(args[1])) goto argterror;
  696.             enter_class(leftp, args[1]);
  697.             goto return_nil;
  698.  
  699.         case 99:    /* find a class in class dictionary */
  700.             if (numargs != 1) goto argcerror;
  701.             resultobj = lookup_class(leftp);
  702.             if (resultobj == (object *) 0) {
  703.                 sprintf(strbuffer,"cannot find class %s",
  704.                 leftp);
  705.                 sassign(resultobj, new_str(strbuffer));
  706.                 primitive(ERRPRINT, 1, &resultobj);
  707.                 obj_dec(resultobj);
  708.                 resultobj = lookup_class("Object");
  709.                 if (! resultobj) cant_happen(7);
  710.                 }
  711.             goto return_obj;
  712.  
  713.         case 100:    /* string length */
  714.             leftint = strlen(leftp);
  715.             goto return_integer;
  716.  
  717.         case 101:     /* string compare, case dependent */
  718.             leftint = strcmp(leftp, rightp);
  719.             goto return_integer;
  720.  
  721.         case 102:    /* string compare, case independent */
  722.             leftint = 1;
  723.             while (*leftp || *rightp) {
  724.                 i = *leftp++;
  725.                 j = *rightp++;
  726.                 if (i >= 'A' && i <= 'Z')
  727.                     i = i - 'A' + 'a';
  728.                 if (j >= 'A' && j <= 'Z')
  729.                     j = j - 'A' + 'a';
  730.                 if (i != j) {leftint = 0; break;}
  731.                 }
  732.             goto return_boolean;
  733.  
  734.         case 103:     /* string catenation */
  735.             for (i = leftint = 0; i < numargs; i++) {
  736.                 if (! is_string(args[i])) goto argterror;
  737.                 leftint += strlen(string_value(args[i]));
  738.                 }
  739.             errp = (char *) o_alloc((unsigned) (1 + leftint));
  740.             *errp = '\0';
  741.             for (i = 0; i < numargs; i++)
  742.                 strcat(errp, string_value(args[i]));
  743.             resultobj = (object *) new_istr(errp);
  744.             goto return_obj;
  745.  
  746.         case 104:    /* string at: */
  747.             if (numargs != 2) goto argcerror;
  748.             leftint = leftp[i];
  749.             goto return_character;
  750.  
  751.         case 105:    /* string at: put: */
  752.             if (numargs != 3) goto argcerror;
  753.             if (! is_character(args[2])) goto argterror;
  754.             leftp[i] = int_value(args[2]);
  755.             goto return_nil;
  756.  
  757.         case 106:    /* copyFrom: length: */
  758.             if (numargs != 3) goto argcerror;
  759.             if (! is_integer(args[2])) goto argterror;
  760.             j = int_value(args[2]);
  761.             if (j < 0) goto indexerror;
  762.             for (rightp = strbuffer; j; j--, i++)
  763.                 *rightp++ = leftp[i];
  764.             *rightp = '\0';
  765.             goto return_string;
  766.  
  767.         case 107:    /* string copy */
  768.             resultobj = new_str(leftp);
  769.             goto return_obj;
  770.  
  771.         case 108:    /* string asSymbol */
  772.             resultobj = new_sym(leftp);
  773.             goto return_obj;
  774.  
  775.         case 109:    /* string printString */
  776.             sprintf(strbuffer,"\'%s\'", leftp);
  777.             goto return_string;
  778.  
  779.         case 110:    /* new untyped object */
  780.             if (numargs != 1) goto argcerror;
  781.             if (! is_integer(args[0])) goto argterror;
  782.             leftint = int_value(args[0]);
  783.             if (leftint < 0) goto numerror;
  784.             resultobj = new_obj((class *) 0, leftint, 1);
  785.             goto return_obj;
  786.  
  787.         case 111:    /* object at: */
  788.             if (numargs != 2) goto argcerror;
  789.             resultobj = args[0]->inst_var[ i - 1 ];
  790.             goto return_obj;
  791.  
  792.         case 112:    /* object at:put: */
  793.             if (numargs != 3) goto argcerror;
  794.             assign(args[0]->inst_var[i - 1], args[2]);
  795.             goto return_nil;
  796.  
  797.         case 113:    /*  object grow */
  798.             leftarg = args[0];
  799.             rightarg = args[1];
  800.             if (is_bltin(leftarg)) goto argterror;
  801.             resultobj = new_obj(leftarg->class,
  802.                 leftarg->size+1, 0);
  803.             if (leftarg->super_obj)
  804.                 sassign(resultobj->super_obj,
  805.                     leftarg->super_obj);
  806.             for (i = 0; i < leftarg->size; i++)
  807.                 sassign(resultobj->inst_var[i], leftarg->inst_var[i]);
  808.             sassign(resultobj->inst_var[i], rightarg);
  809.             goto return_obj;
  810.  
  811.  
  812.         case 114:    /* new array */
  813.             resultobj = new_array(i, 1);
  814.             goto return_obj;
  815.  
  816.         case 115:    /* new string */
  817.             for (j = 0; j < i; j++)
  818.                 strbuffer[j] = ' ';
  819.             strbuffer[j] = '\0';
  820.             goto return_string;
  821.  
  822.         case 116:    /* bytearray new */
  823.             /* initialize with random garbage */
  824.             resultobj = new_bytearray(strbuffer, i);
  825.             goto return_obj;
  826.  
  827.         case 117:    /* bytearray size */
  828.             if (numargs != 1) goto argcerror;
  829.             leftint = byarray->a_bsize;
  830.             goto return_integer;
  831.  
  832.         case 118:    /* bytearray at: */
  833.             if (numargs != 2) goto argcerror;
  834.             leftint = uctoi(byarray->a_bytes[i]);
  835.             goto return_integer;
  836.  
  837.         case 119:    /* bytearray at:put: */
  838.             if (numargs != 3) goto argcerror;
  839.             if (! int_value(args[2])) goto argterror;
  840.             byarray->a_bytes[i] = itouc(int_value(args[2]));
  841.             goto return_nil;
  842.  
  843.         case 120:    /* print, no return */
  844.             printf("%s", leftp);
  845. # ifdef FLUSHREQ
  846.             fflush(stdout);
  847. # endif
  848.             goto return_nil;
  849.  
  850.         case 121:    /* print, with return */
  851.             printf("%s\n", leftp);
  852. # ifdef FLUSHREQ
  853.             fflush(stdout);
  854. # endif
  855.             goto return_nil;
  856.  
  857.         case 122:    /* format for error printing */
  858.             aClass = (class *) fnd_class(args[1]);
  859.             sprintf(strbuffer,"%s: %s",
  860.                 symbol_value(aClass->class_name), leftp);
  861.             leftp = strbuffer;
  862.  
  863.         case 123:    /* print on error output */
  864.             fprintf(stderr,"%s\n", leftp);
  865. # ifdef FLUSHREQ
  866.             fflush(stderr);
  867. # endif
  868.             goto return_nil;
  869.  
  870.         case 125:    /* unix system call */
  871. # ifndef NOSYSTEM
  872.             leftint = system(leftp);
  873.             goto return_integer;
  874. # endif
  875. # ifdef NOSYSTEM
  876.             errp = "system()";
  877.             goto not_implemented;
  878. # endif
  879.  
  880.         case 126:    /* printAt: */
  881. # ifndef CURSES
  882.             errp = "curses graphics package not available";
  883.             goto return_error;
  884. # endif
  885. # ifdef CURSES
  886.             if (numargs != 3) goto argcerror;
  887.             if ((! is_string(args[0])) ||
  888.                 (! is_integer(args[1])) ||
  889.                 (! is_integer(args[2])) ) goto argterror;
  890.             move(int_value(args[1]), int_value(args[2]));
  891.             addstr(string_value(args[0]));
  892.             refresh();
  893.             move(0, LINES-1);
  894.             goto return_nil;
  895. # endif
  896.  
  897.         case 127:    /* block return */
  898.             errp = "block return without surrounding context";
  899.             goto return_error;
  900.  
  901.         case 128: /* reference count error */
  902.             if (numargs != 1) goto argcerror;
  903.             sprintf(strbuffer,"object %d reference count %d",
  904.                 args[0], args[0]->ref_count);
  905.             errp = strbuffer;
  906.             goto return_error;
  907.  
  908.         case 129: /* does not respond error */
  909.             if (numargs != 2) goto argcerror;
  910.             if (! is_symbol(args[1])) goto argterror;
  911.             fprintf(stderr,"respond error: %s\n",
  912.             symbol_value(args[1]));
  913.             aClass = (class *) fnd_class(args[0]);
  914.             if (! is_class(aClass)) goto argterror;
  915.             sprintf(strbuffer,"%s: does not respond to %s",
  916.                 symbol_value(aClass->class_name),
  917.                 symbol_value(args[1]));
  918.             errp = strbuffer;
  919.             goto return_error;
  920.  
  921.         case 130:    /* file open */
  922.             if (numargs != 3) goto argcerror;
  923.             if (! is_string(args[1])) goto argterror;
  924.             if (! is_string(args[2])) goto argterror;
  925.             file_open(phil,
  926.                 string_value(args[1]), string_value(args[2]));
  927.             goto return_nil;
  928.  
  929.         case 131:    /* file read */
  930.             if (numargs != 1) goto argcerror;
  931.             resultobj = file_read(phil);
  932.             goto return_obj;
  933.  
  934.         case 132:    /* file write */
  935.             if (numargs != 2) goto argcerror;
  936.             file_write(phil, args[1]);
  937.             goto return_nil;
  938.  
  939.         case 133:    /* set file mode */
  940.             if (numargs != 2) goto argcerror;
  941.             if (! is_integer(args[1])) goto argterror;
  942.             phil->file_mode = int_value(args[1]);
  943.             goto return_nil;
  944.  
  945.         case 134:    /* compute file size */
  946.             fseek(phil->fp, (long) 0, 2);
  947.             leftint = (int) ftell(phil->fp);
  948.             goto return_integer;
  949.  
  950.         case 135:    /* set file position */
  951.             if (numargs != 2) goto argcerror;
  952.             if (! is_integer(args[1])) goto argterror;
  953.             leftint = fseek(phil->fp, (long) int_value(args[1]), 0);
  954.             goto return_integer;
  955.  
  956.         case 136:    /* find current position */
  957.             if (numargs != 1) goto argcerror;
  958.             leftint = (int) ftell(phil->fp);
  959.             goto return_integer;
  960.  
  961.         case 140:
  962.             errp = "block execute should be trapped by interp";
  963.             goto return_error;
  964.  
  965.         case 141:    /* newProcess (withArguments:) */
  966.             if (numargs < 1) goto argcerror;
  967.             if (! is_block(args[0])) goto argterror;
  968.             if (numargs == 1)
  969.                 resultobj = (object *)
  970.                     block_execute((interpreter *) 0,
  971.                     (block *) args[0], 0, args);
  972.             else if (numargs == 2)
  973.                 resultobj = (object *)
  974.                     block_execute((interpreter *) 0,
  975.                     (block *) args[0], args[1]->size,
  976.                     &(args[1]->inst_var[0]));
  977.             else goto argcerror;
  978.             if (((object *) 0) == resultobj) goto return_nil;
  979.             resultobj = (object *) cr_process(resultobj);
  980.             goto return_obj;
  981.  
  982.         case 142:    /* terminate a process */
  983.             if (numargs != 1) goto argcerror;
  984.             if (! is_process(args[0])) goto argterror;
  985.             terminate_process( (process *) args[0]);
  986.             goto return_nil;
  987.  
  988.         case 143:    /* perform:withArguments: */
  989.             errp = "perform should be trapped by interpreter";
  990.             goto return_error;
  991.  
  992.         case 145:    /* set the state of a process */
  993.             if (numargs != 2) goto argcerror;
  994.             if (! is_process(args[0])) goto argterror;
  995.             if (! is_integer(args[1])) goto argterror;
  996.             leftint = int_value(args[1]);
  997.             switch (leftint) {
  998.                 case 0:    leftint = READY;
  999.                     break;
  1000.                 case 1:    leftint = SUSPENDED;
  1001.                     break;
  1002.                 case 2:    leftint = BLOCKED;
  1003.                     break;
  1004.                 case 3:    leftint = UNBLOCKED;
  1005.                     break;
  1006.                 default:  errp = "invalid state for process";
  1007.                       goto return_error;
  1008.  
  1009.                 }
  1010.             set_state((process *) args[0], leftint);
  1011.             goto return_integer;
  1012.  
  1013.         case 146:    /* return the state of a process */
  1014.             if (numargs != 1) goto argcerror;
  1015.             if (! is_process(args[0])) goto argterror;
  1016.             leftint = set_state((process *) args[0], CUR_STATE);
  1017.             goto return_integer;
  1018.  
  1019.         case 148:    /* begin atomic action */
  1020.             if (numargs != 0) goto argcerror;
  1021.             atomcnt++;
  1022.             goto return_nil;
  1023.  
  1024.         case 149:    /* end atomic action */
  1025.             if (numargs != 0) goto argcerror;
  1026.             if (atomcnt == 0) {
  1027.                 errp = "end atomic attempted while not in atomic action";
  1028.                 goto return_error;
  1029.                 }
  1030.             atomcnt--;
  1031.             goto return_nil;
  1032.  
  1033.         case 150:    /* class edit */
  1034.             leftp = symbol_value(aClass->file_name);
  1035.             if (! writeable(leftp)) {
  1036.                 gettemp(tempname);
  1037.                 sprintf(strbuffer,"cp %s %s", leftp, tempname);
  1038. # ifndef NOSYSTEM
  1039.                 system(strbuffer);
  1040. # endif
  1041.                 leftp = tempname;
  1042.                 }
  1043.             if (! lexedit(leftp)) lexinclude(leftp);
  1044.             goto return_nil;
  1045.  
  1046.         case 151:     /* superclass of a class */
  1047.             if (! aClass->super_class)
  1048.                 goto return_nil;
  1049.             resultobj = (object *) aClass->super_class;
  1050.             if (! is_symbol(resultobj)) goto return_nil;
  1051.             resultobj = lookup_class(symbol_value(resultobj));
  1052.             if (! resultobj) goto return_nil;
  1053.             goto return_obj;
  1054.  
  1055.         case 152: /* class name */
  1056.             resultobj = aClass->class_name;
  1057.             leftp = symbol_value(resultobj);
  1058.             resultobj = new_str(leftp);
  1059.             goto return_obj;
  1060.  
  1061.         case 153: /* new */
  1062.             if (numargs != 2) goto argcerror;
  1063.             if (args[1] == o_nil)
  1064.                 resultobj = new_inst(aClass);
  1065.             else
  1066.                 resultobj = new_sinst(aClass, args[1]);
  1067.             goto return_obj;
  1068.  
  1069.         case 154:    /* print message names list */
  1070.             prnt_messages(aClass);
  1071.             goto return_nil;
  1072.  
  1073.         case 155:     /* respondsTo: aMessage  */
  1074.             if (numargs != 2) goto argcerror;
  1075.             if (! is_symbol(args[1])) goto argterror;
  1076.             leftint = responds_to(symbol_value(args[1]), aClass);
  1077.             goto return_boolean;
  1078.  
  1079.         case 156:    /* class view */
  1080. # ifndef NOSYSTEM
  1081.             leftp = symbol_value(aClass->file_name);
  1082.             gettemp(tempname);
  1083.             sprintf(strbuffer,"cp %s %s", leftp, tempname);
  1084.             system(strbuffer);
  1085.             leftp = tempname;
  1086.             lexedit(leftp);
  1087.             goto return_nil;
  1088. # endif
  1089. # ifdef NOSYSTEM
  1090.             errp = "cannot view classes on this system";
  1091.             goto return_error;
  1092. # endif
  1093.  
  1094.         case 157:    /* class list */
  1095.             class_list(aClass, 0);
  1096.             goto return_nil;
  1097.  
  1098.  
  1099.         case 158:    /* variables */
  1100.             resultobj = aClass->c_inst_vars;
  1101.             goto return_obj;
  1102.  
  1103.         case 160:    /* current time */
  1104.             time(&clock);
  1105.             strcpy(strbuffer, ctime(&clock));
  1106.             goto return_string;
  1107.  
  1108.         case 161:    /* time, measure in seconds */
  1109.             leftint = (int) time((long *) 0);
  1110.             goto return_integer;
  1111.  
  1112.         case 162:    /* clear screen */
  1113. # ifdef CURSES
  1114.             clear();
  1115.             move(0,0);
  1116.             refresh();
  1117. # endif
  1118. # ifdef PLOT3
  1119.             erase();
  1120. # endif
  1121.             goto return_nil;
  1122.  
  1123.         case 163:    /* getString */
  1124.             gets(strbuffer);
  1125.             goto return_string;
  1126.  
  1127.         case 164:    /* string asInteger */
  1128.             if (! is_string(args[0])) goto argterror;
  1129.             leftint = atoi(string_value(args[0]));
  1130.             goto return_integer;
  1131.  
  1132.         case 165:    /* string asFloat */
  1133.             if (! is_string(args[0])) goto argterror;
  1134.             leftfloat = atof(string_value(args[0]));
  1135.             goto return_float;
  1136.  
  1137. # ifdef PLOT3
  1138.  
  1139. /**************************
  1140.     warning - the calls on the plot(3) routines are very device
  1141.     specific, and will probably require changes to work on any one
  1142.     particular new device
  1143. **********************************/
  1144.         case 170:    /* clear */
  1145.             erase();
  1146.             goto return_nil;
  1147.  
  1148.         case 171:    /* move(x,y) */
  1149.             move(leftint, rightint);
  1150.             goto return_nil;
  1151.  
  1152.         case 172:    /* cont(x,y) (draw line) */
  1153.             cont(leftint, rightint);
  1154.             goto return_nil;
  1155.  
  1156.         case 173:    /* point(x,y) (draw point) */
  1157.             point(leftint, rightint);
  1158.             goto return_nil;
  1159.  
  1160.         case 174:    /* circle(x, y, r) */
  1161.             if (numargs != 3) goto argcerror;
  1162.             for (i = 0; i < 3; i++)
  1163.                 if (! is_integer(args[i]))
  1164.                     goto argterror;
  1165.             circle(int_value(args[0]), int_value(args[1]),
  1166.                 int_value(args[2]));
  1167.             goto return_nil;
  1168.  
  1169.         case 175:    /* arg(x, y, x0, y0, x1, y1) */
  1170.             if (numargs != 6) goto argcerror;
  1171.             for (i = 0; i < 6; i++)
  1172.                 if (! is_integer(args[i])) goto argterror;
  1173.             arc(int_value(args[0]), int_value(args[1]),
  1174.                 int_value(args[2]), int_value(args[3]),
  1175.                 int_value(args[4]), int_value(args[5]));
  1176.             goto return_nil;
  1177.  
  1178.         case 176:    /* space */
  1179.             space(leftint, rightint, i, j);
  1180.             goto return_nil;
  1181.  
  1182.         case 177:    /* line */
  1183.             line(leftint, rightint, i, j);
  1184.             goto return_nil;
  1185.  
  1186.         case 178:    /* label */
  1187.             label(leftp);
  1188.             goto return_nil;
  1189.  
  1190.         case 179:    /* linemod */
  1191.             linemod(leftp);
  1192.             goto return_nil;
  1193. # endif
  1194.  
  1195.         default: fprintf(stderr,"Primitive number %d not implemented\n",
  1196.                         primnumber);
  1197.             goto return_nil;
  1198.     }
  1199.  
  1200. /* return different types of objects */
  1201.  
  1202. return_obj:
  1203.  
  1204.     return(resultobj);
  1205.  
  1206. return_nil:
  1207.  
  1208.     return(o_nil);
  1209.  
  1210. return_integer:
  1211.  
  1212.     return(new_int(leftint));
  1213.  
  1214. return_character:
  1215.  
  1216.     return(new_char(leftint));
  1217.  
  1218. return_boolean:
  1219.  
  1220.     return(leftint ? o_true : o_false);
  1221.  
  1222. float_check:
  1223.  
  1224.     if (errno == ERANGE || errno == EDOM) goto numerror;
  1225.  
  1226. return_float:
  1227.  
  1228.     return(new_float(leftfloat));
  1229.  
  1230. return_string:
  1231.  
  1232.     return(new_str(strbuffer));
  1233.  
  1234. /* error conditions */
  1235.  
  1236. not_implemented:
  1237.     sprintf(strbuffer,"%s not implemented yet", errp);
  1238.     errp = strbuffer;
  1239.     goto return_error;
  1240.  
  1241. argcerror:
  1242.     sprintf(strbuffer,"%d is wrong number of arguments for primitive %d",
  1243.         numargs, primnumber);
  1244.     errp = strbuffer;
  1245.     goto return_error;
  1246.  
  1247. argterror:
  1248.     sprintf(strbuffer,"argument type not correct for primitive %d",
  1249.         primnumber);
  1250.     errp = strbuffer;
  1251.     goto return_error;
  1252.  
  1253. numerror:
  1254.     errp = "numerical error in primitive";
  1255.     goto return_error;
  1256.  
  1257. indexerror:
  1258.     errp = "primitive index error";
  1259.     goto return_error;
  1260.  
  1261. return_error:
  1262.     sassign(resultobj, new_str(errp));
  1263.     primitive(ERRPRINT, 1, &resultobj);
  1264.     obj_dec(resultobj);
  1265.     goto return_nil;
  1266. }
  1267.  
  1268. static prnt_radix(n, r, buffer)
  1269. int n, r;
  1270. char buffer[];
  1271. {  char *p, *q, buffer2[60];
  1272.    int i, s;
  1273.  
  1274.    if (n < 0) {n = - n; s = 1;}
  1275.    else s = 0;
  1276.    p = buffer2; *p++ = '\0';
  1277.    if (n == 0) *p++ = '0';
  1278.    while (n) {
  1279.       i = n % r;
  1280.       *p++ = i + ((i < 10) ?  '0' : ('A' - 10));
  1281.       n = n / r;
  1282.       }
  1283.    sprintf(buffer,"%dr", r);
  1284.    for (q = buffer; *q; q++);
  1285.    if (s) *q++ = '-';
  1286.    for (*p = '0' ; *p ; ) *q++ = *--p;
  1287.    *q = '\0';
  1288. }
  1289.  
  1290. static fprnt_radix(f, n, buffer)
  1291. double f;
  1292. int n;
  1293. char buffer[];
  1294. {    int sign, exp, i, j;
  1295.     char *p, *q, tempbuffer[60];
  1296.     double ip;
  1297.  
  1298.     if (f < 0) {
  1299.         sign = 1;
  1300.         f = - f;
  1301.         }
  1302.     else sign = 0;
  1303.     exp = 0;
  1304.     if (f != 0) {
  1305.         exp = (int) floor(log(f) / log((double) n));
  1306.         if (exp < -4 || 4 < exp) {
  1307.             f *= pow((double) n, (double) - exp);
  1308.             }
  1309.         else exp = 0;
  1310.         }
  1311.     f = modf(f, &ip);
  1312.     if (sign) ip = - ip;
  1313.     prnt_radix((int) ip, n, buffer);
  1314.     for (p = buffer; *p; p++) ;
  1315.     if (f != 0) {
  1316.         *p++ = '.';
  1317.         for (j = 0; (f != 0) && (j < 6); j++){
  1318.             i = (int) (f *= n);
  1319.             *p++ = (i < 10) ? '0' + i : 'A' + (i-10) ;
  1320.             f -= i;
  1321.             }
  1322.         }
  1323.     if (exp) {
  1324.         *p++ = 'e';
  1325.         sprintf(tempbuffer,"%d", exp);
  1326.         for (q = tempbuffer; *q; )
  1327.             *p++ = *q++;
  1328.         }
  1329.     *p = '\0';
  1330.     return;
  1331. }
  1332.  
  1333. /* generalit - numerical generality */
  1334. static int generality(aNumber)
  1335. object *aNumber;
  1336. {    int i;
  1337.  
  1338.     if (is_integer(aNumber)) i = 1;
  1339.     else if (is_float(aNumber)) i = 2;
  1340.     else i = 3;
  1341.     return(i);
  1342. }
  1343.  
  1344. /* cant_happen - report that an impossible condition has occured */
  1345. cant_happen(n) int n;
  1346. {   char *s;
  1347.  
  1348. # ifdef SMALLDATA
  1349.     s = "what a pain!";
  1350. # endif
  1351. # ifndef SMALLDATA
  1352.     switch(n) {
  1353.        case 1:  s = "out of memory allocation space"; break;
  1354.        case 2:  s = "array size less than zero"; break;
  1355.        case 3:  s = "block return from call should not occur"; break;
  1356.        case 4:  s = "attempt to make instance of non class"; break;
  1357.        case 5:  s = "case error in new integer or string"; break;
  1358.        case 6:  s = "decrement on unknown built in object"; break;
  1359.        case 7:  s = "cannot find class Object"; break;
  1360.        case 8:  s = "primitive free of object of wrong type"; break;
  1361.        case 9:  s = "internal interpreter error"; break;
  1362.        case 11: s = "block execute on non-block"; break;
  1363.        case 12: s = "out of symbol space"; break;
  1364.        case 14: s = "out of standard bytecode space"; break;
  1365.        case 15: s = "system deadlocked - all processes blocked"; break;
  1366.        case 16: s = "attempt to free symbol"; break;
  1367.        case 17: s = "invalid process state passed to set_state"; break;
  1368.        case 18: s = "internal buffer overflow"; break;
  1369.        case 20: s = "can't open prelude file"; break;
  1370.        case 22: s = "system file open error"; break;
  1371.        case 23: s = "fastsave error"; break;
  1372.        default: s = "unknown, but impossible nonetheless, condition"; break;
  1373.        }
  1374. # endif
  1375.    fprintf(stderr,"Can't happen number %d: %s\n", n, s);
  1376.    exit(1);
  1377. }
  1378.  
  1379. /* writeable - see if a file can be written to */
  1380. int writeable(name)
  1381. char *name;
  1382. {    char buffer[150];
  1383.  
  1384.     sprintf(buffer,"test -w %s", name);
  1385. # ifdef NOSYSTEM
  1386.     return(0);
  1387. # endif
  1388. # ifndef NOSYSTEM
  1389.     return(! system(buffer));
  1390. # endif
  1391. }
  1392.